#lang racket

(require "util/utils.scm")
(require "util/gensym.scm")
(provide pass-letrec)

(define (pass-letrec defs)
  (map* pass-letrec-def defs))

(define (pass-letrec-def def)
  (match def
    (`(define ,name ,body)
     `(define ,name ,(pass-letrec-exp body)))
    (`(dont-define ,body)
     `(dont-define ,(pass-letrec-exp body)))
    (else (error 'pass-letrec-def "malformed toplevel definition" def))))
     
(define (pass-letrec-exp exp)
  (match exp
    (`(quote ,x) `(quote ,x))
    (`(string ,s) `(string ,s))
    (`(atomic ,x) `(atomic ,x))
    (`(var ,ty ,x) `(var ,ty ,x))
    (`(app . ,exps) `(app . ,(map pass-letrec-exp exps)))
    (`(builtin ,f . ,exps) `(builtin ,f . ,(map pass-letrec-exp exps)))
    (`(begin . ,exps) `(begin . ,(map pass-letrec-exp exps)))
    (`(closure ,env ,resolv-env ,binds ,body)
     `(closure ,env ,resolv-env ,binds ,(pass-letrec-exp body)))
    (`(if ,t ,c ,a)
     `(if ,(pass-letrec-exp t)
          ,(pass-letrec-exp c)
          ,(pass-letrec-exp a)))
    (`(let* ,bindings ,body)
     `(let* ,(map* (lambda (bind)
		     (list (car bind) (pass-letrec-exp (cadr bind)))) bindings)
	,(pass-letrec-exp body)))
    (`(letrec ,bindings ,body)
     (let* ((co (make-collector))
	    (bound-names (map car bindings))
	    (dummied-closures
	     (map (lambda (nm val)
		    (match val
		      (`(closure ,env ,resolv-env ,binds ,body)
		       (let* ((i -1)
			      (resolv-env^ (map (lambda (var)
						  (match var
						    (`(var tmp ,x)
						     (set! i (+ i 1))
						     (if (member x bound-names)
							 (begin
							   (collect-object! co `(builtin closure-env-set! (var tmp ,nm) (atomic ,i) ,var))
							   '(atomic #f))
							 var))
						    (else var)))
						resolv-env)))
			 `(closure ,env ,resolv-env^ ,binds ,(pass-letrec-exp body))))
		      (else (error 'pass-letrec-exp "non closure in letrec"))))
		  (map car bindings)
		  (map cadr bindings))))
       (collect-object! co (pass-letrec-exp body))
       `(let* ,(map (lambda (nm val)
		      (list nm val))
		    bound-names
		    dummied-closures)
	  (begin . ,(collector-get co)))))
    (else (error 'pass-letrec-exp "?" exp))))
